home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2007 September / PCWSEP07.iso / Software / Linux / Linux Mint 3.0 Light / LinuxMint-3.0-Light.iso / casper / filesystem.squashfs / usr / sbin / update-binfmts < prev    next >
Encoding:
Text File  |  2006-06-19  |  19.3 KB  |  719 lines
  1. #! /usr/bin/perl -w
  2.  
  3. # Copyright (c) 2000, 2001, 2002 Colin Watson <cjwatson@debian.org>.
  4. # See update-binfmts(8) for documentation.
  5. #
  6. # This program is free software; you can redistribute it and/or modify
  7. # it under the terms of the GNU General Public License as published by
  8. # the Free Software Foundation; either version 2 of the License, or
  9. # (at your option) any later version.
  10. #
  11. # This program is distributed in the hope that it will be useful,
  12. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. # GNU General Public License for more details.
  15. #
  16. # You should have received a copy of the GNU General Public License
  17. # along with this program; if not, write to the Free Software
  18. # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  19.  
  20. use strict;
  21.  
  22. use POSIX qw(uname);
  23. use Text::Wrap;
  24. use Binfmt::Lib qw($admindir $importdir $procdir $auxdir quit warning);
  25. use Binfmt::Format;
  26.  
  27. my $VERSION = '1.2.8';
  28.  
  29. $Text::Wrap::columns = 79;
  30.  
  31. use vars qw($test);
  32.  
  33. my $register = "$procdir/register";
  34. my $status = "$procdir/status";
  35. my $run_detectors = "$auxdir/run-detectors";
  36.  
  37. my %formats;
  38.  
  39. # Various "print something and exit" routines.
  40.  
  41. sub version ()
  42. {
  43.     print "update-binfmts $VERSION.\n"
  44.     or die "unable to write version message: $!";
  45. }
  46.  
  47. sub usage ()
  48. {
  49.     version;
  50.     print <<EOF
  51. Copyright (c) 2000, 2001, 2002 Colin Watson. This is free software; see
  52. the GNU General Public License version 2 or later for copying conditions.
  53.  
  54. Usage:
  55.  
  56.   update-binfmts [options] --install <name> <path> <spec>
  57.   update-binfmts [options] --remove <name> <path>
  58.   update-binfmts [options] --import [<name>]
  59.   update-binfmts [options] --display [<name>]
  60.   update-binfmts [options] --enable [<name>]
  61.   update-binfmts [options] --disable [<name>]
  62.  
  63.   where <spec> is one of:
  64.  
  65.     --magic <byte-sequence> [--mask <byte-sequence>] [--offset <offset>]
  66.     --extension <extension>
  67.  
  68.   The following argument may be added to any <spec> to have a userspace
  69.   process determine whether the file should be handled:
  70.  
  71.     --detector <path>
  72.  
  73. Options:
  74.  
  75.     --package <package-name>    for --install and --remove, specify the
  76.                                 current package name
  77.     --admindir <directory>      use <directory> instead of /var/lib/binfmts
  78.                                 as administration directory
  79.     --importdir <directory>     use <directory> instead of /usr/share/binfmts
  80.                                 as import directory
  81.     --test                      don't do anything, just demonstrate
  82.     --help                      print this help screen and exit
  83.     --version                   output version and exit
  84.  
  85. EOF
  86.     or die "unable to write usage message: $!";
  87. }
  88.  
  89. sub usage_quit ($;@)
  90. {
  91.     my $me = $0;
  92.     $me =~ s#.*/##;
  93.     print STDERR wrap '', '', "$me:", @_, "\n";
  94.     usage;
  95.     exit 2;
  96. }
  97.  
  98. sub check_supported_os ()
  99. {
  100.     my $sysname = (uname)[0];
  101.     return if $sysname eq 'Linux';
  102.     print <<EOF;
  103. Sorry, update-binfmts currently only works on Linux.
  104. EOF
  105.     if ($sysname eq 'GNU') {
  106.     print <<EOF;
  107. Patches for Hurd support are welcomed; they should not be difficult.
  108. EOF
  109.     }
  110.     exit 2;
  111. }
  112.  
  113. # Make sure options are unambiguous.
  114.  
  115. sub check_modes ($$)
  116. {
  117.     return unless $_[0];
  118.     usage_quit "two modes given: --$_[0] and $_[1]";
  119. }
  120.  
  121. sub check_types ($$)
  122. {
  123.     return unless $_[0];
  124.     usage_quit "two binary format specifications given: --$_[0] and $_[1]";
  125. }
  126.  
  127. sub rename_mv ($$)
  128. {
  129.     my ($source, $dest) = @_;
  130.     return (rename($source, $dest) || (system('mv', $source, $dest) == 0));
  131. }
  132.  
  133. sub get_import ($)
  134. {
  135.     my $name = shift;
  136.     my %import;
  137.     local *IMPORT;
  138.     unless (open IMPORT, "< $name") {
  139.     warning "unable to open $name: $!";
  140.     return;
  141.     }
  142.     local $_;
  143.     while (<IMPORT>) {
  144.     chomp;
  145.     my ($name, $value) = split ' ', $_, 2;
  146.     $import{lc $name} = $value;
  147.     }
  148.     close IMPORT;
  149.     return %import;
  150. }
  151.  
  152. # Loading and unloading logic, which should cope with the various ways this
  153. # has been implemented.
  154.  
  155. sub get_binfmt_style ()
  156. {
  157.     my $style;
  158.     local *FS;
  159.     unless (open FS, '/proc/filesystems') {
  160.     # Weird. Assume procfs.
  161.     warning "unable to open /proc/filesystems: $!";
  162.     return 'procfs';
  163.     }
  164.     if (grep m/\bbinfmt_misc\b/, <FS>) {
  165.     # As of 2.4.3, the official Linux kernel still uses the original
  166.     # interface, but Alan Cox's patches add a binfmt_misc filesystem
  167.     # type which needs to be mounted separately. This may get into the
  168.     # official kernel in the future, so support both.
  169.     $style = 'filesystem';
  170.     } else {
  171.     # The traditional interface.
  172.     $style = 'procfs';
  173.     }
  174.     close FS;
  175.     return $style;
  176. }
  177.  
  178. sub load_binfmt_misc ()
  179. {
  180.     if ($test) {
  181.     print "load binfmt_misc\n";
  182.     return 1;
  183.     }
  184.  
  185.     my $style = get_binfmt_style;
  186.     # If the style is 'filesystem', then we must already have the module
  187.     # loaded, as binfmt_misc wouldn't show up in /proc/filesystems
  188.     # otherwise.
  189.     if ($style eq 'procfs' and not -f $register) {
  190.     if (not -x '/sbin/modprobe' or system qw(/sbin/modprobe binfmt_misc)) {
  191.         warning "Couldn't load the binfmt_misc module.";
  192.         return 0;
  193.     }
  194.     }
  195.  
  196.     unless (-d $procdir) {
  197.     warning "binfmt_misc module seemed to be loaded, but no $procdir",
  198.         "directory! Giving up.";
  199.     return 0;
  200.     }
  201.  
  202.     # Find out what the style looks like now.
  203.     $style = get_binfmt_style;
  204.     if ($style eq 'filesystem' and not -f $register) {
  205.     if (system qw(/bin/mount -t binfmt_misc binfmt_misc), $procdir) {
  206.         warning "Couldn't mount the binfmt_misc filesystem on $procdir.";
  207.         return 0;
  208.     }
  209.     }
  210.  
  211.     if (-f $register) {
  212.     local *STATUS;
  213.     if (open STATUS, "> $status") {
  214.         print STATUS "1\n";
  215.         close STATUS;
  216.     } else {
  217.         warning "unable to open $status for writing: $!";
  218.     }
  219.     return 1;
  220.     } else {
  221.     warning "binfmt_misc initialized, but $register missing! Giving up.";
  222.     return 0;
  223.     }
  224. }
  225.  
  226. sub unload_binfmt_misc ()
  227. {
  228.     my $style = get_binfmt_style;
  229.  
  230.     if ($test) {
  231.     print "unload binfmt_misc ($style)\n";
  232.     return 1;
  233.     }
  234.  
  235.     if ($style eq 'filesystem') {
  236.     if (system '/bin/umount', $procdir) {
  237.         warning "Couldn't unmount the binfmt_misc filesystem from",
  238.             "$procdir.";
  239.         return 0;
  240.     }
  241.     }
  242.     # We used to try to unload the kernel module as well, but it seems that
  243.     # it doesn't always unload properly (http://bugs.debian.org/155570) and
  244.     # in any case it means that strictly speaking we have to remember if the
  245.     # module was loaded when we started. Since it's not actually important,
  246.     # we now just don't bother.
  247.     return 1;
  248. }
  249.  
  250. # Actions.
  251.  
  252. # Enable a binary format in the kernel.
  253. sub act_enable (;$);
  254. sub act_enable (;$)
  255. {
  256.     my $name = shift;
  257.     return 1 unless load_binfmt_misc;
  258.     if (defined $name) {
  259.     unless ($test or exists $formats{$name}) {
  260.         warning "$name not in database of installed binary formats.";
  261.         return 0;
  262.     }
  263.     my $binfmt = $formats{$name};
  264.     my $type = ($binfmt->{type} eq 'magic') ? 'M' : 'E';
  265.  
  266.     my $need_detector = (defined $binfmt->{detector} and
  267.                  length $binfmt->{detector}) ? 1 : 0;
  268.     unless ($need_detector) {
  269.         # Scan the format database to see if anything else uses the same
  270.         # spec as us. If so, assume that we need a detector, effectively
  271.         # /bin/true. Don't actually set $binfmt->{detector} though,
  272.         # since run-detectors optimizes the case of empty detectors and
  273.         # "runs" them last.
  274.         for my $id (keys %formats) {
  275.         next if $id eq $name;
  276.         if ($binfmt->equals ($formats{$id})) {
  277.             $need_detector = 1;
  278.             last;
  279.         }
  280.         }
  281.     }
  282.     # Fake the interpreter if we need a userspace detector program.
  283.     my $interpreter = $need_detector ? $run_detectors
  284.                      : $binfmt->{interpreter};
  285.  
  286.     my $regstring = ":$name:$type:$binfmt->{offset}:$binfmt->{magic}" .
  287.             ":$binfmt->{mask}:$interpreter:\n";
  288.     if ($test) {
  289.         print "enable $name with the following format string:\n",
  290.           " $regstring";
  291.     } else {
  292.         local *REGISTER;
  293.         unless (open REGISTER, ">$register") {
  294.         warning "unable to open $register for writing: $!";
  295.         return 0;
  296.         }
  297.         print REGISTER $regstring;
  298.         unless (close REGISTER) {
  299.         warning "unable to close $register: $!";
  300.         return 0;
  301.         }
  302.     }
  303.     return 1;
  304.     } else {
  305.     my $worked = 1;
  306.     for my $id (keys %formats) {
  307.         unless (-e "$procdir/$id") {
  308.         $worked &= act_enable $id;
  309.         }
  310.     }
  311.     return $worked;
  312.     }
  313. }
  314.  
  315. # Disable a binary format in the kernel.
  316. sub act_disable (;$);
  317. sub act_disable (;$)
  318. {
  319.     my $name = shift;
  320.     return 1 unless -d $procdir;    # We're disabling anyway, so we don't mind
  321.     if (defined $name) {
  322.     unless (-e "$procdir/$name") {
  323.         # Don't warn in this circumstance, as it could happen e.g. when
  324.         # binfmt-support and a package depending on it are upgraded at
  325.         # the same time, so we get called when stopped. Just pretend
  326.         # that the disable operation succeeded.
  327.         return 1;
  328.     }
  329.  
  330.     # We used to check the entry in $procdir to make sure we were
  331.     # removing an entry with the same interpreter, but this is bad; it
  332.     # makes things really difficult for packages that want to change
  333.     # their interpreter, for instance. Now we unconditionally remove and
  334.     # rely on the calling logic to check that the entry in $admindir
  335.     # belongs to the same package.
  336.     # 
  337.     # In other words, $admindir becomes the canonical reference, not
  338.     # $procdir. This is in line with similar update-* tools in Debian.
  339.  
  340.     if ($test) {
  341.         print "disable $name\n";
  342.     } else {
  343.         local *PROCENTRY;
  344.         unless (open PROCENTRY, ">$procdir/$name") {
  345.         warning "unable to open $procdir/$name for writing: $!";
  346.         return 0;
  347.         }
  348.         print PROCENTRY -1;
  349.         unless (close PROCENTRY) {
  350.         warning "unable to close $procdir/$name: $!";
  351.         return 0;
  352.         }
  353.         if (-e "$procdir/$name") {
  354.         warning "removal of $procdir/$name ignored by kernel!";
  355.         return 0;
  356.         }
  357.     }
  358.     return 1;
  359.     }
  360.     else
  361.     {
  362.     my $worked = 1;
  363.     for my $id (keys %formats) {
  364.         if (-e "$procdir/$id") {
  365.         $worked &= act_disable $id;
  366.         }
  367.     }
  368.     unload_binfmt_misc;    # ignore errors here
  369.     return $worked;
  370.     }
  371. }
  372.  
  373. # Install a binary format into binfmt-support's database. Attempt to enable
  374. # the new format in the kernel as well.
  375. sub act_install ($$)
  376. {
  377.     my $name = shift;
  378.     my $binfmt = shift;
  379.     if (exists $formats{$name}) {
  380.     # For now we just silently zap any old versions with the same
  381.     # package name (has to be silent or upgrades are annoying). Maybe we
  382.     # should be more careful in the future.
  383.     my $package = $binfmt->{package};
  384.     my $old_package = $formats{$name}{package};
  385.     unless ($package eq $old_package) {
  386.         $package     = '<local>' if $package eq ':';
  387.         $old_package = '<local>' if $old_package eq ':';
  388.         warning "current package is $package, but binary format already",
  389.             "installed by $old_package";
  390.         return 0;
  391.     }
  392.     unless (act_disable $name) {
  393.         warning "unable to disable binary format $name";
  394.         return 0;
  395.     }
  396.     }
  397.     if (-e "$procdir/$name" and not $test) {
  398.     # This is a bit tricky. If we get here, then the kernel knows about
  399.     # a format we don't. Either somebody has used binfmt_misc directly,
  400.     # or update-binfmts did something wrong. For now we do nothing;
  401.     # disabling and re-enabling all binary formats will fix this anyway.
  402.     # There may be a --force option in the future to help with problems
  403.     # like this.
  404.     # 
  405.     # Disabled for --test, because otherwise it never works; the
  406.     # vagaries of binfmt_misc mean that it isn't really possible to find
  407.     # out from userspace exactly what's going to happen if people have
  408.     # been bypassing update-binfmts.
  409.     warning "found manually created entry for $name in $procdir;",
  410.         "leaving it alone";
  411.     return 1;
  412.     }
  413.  
  414.     if ($test) {
  415.     print "install the following binary format description:\n";
  416.     $binfmt->dump_stdout;
  417.     } else {
  418.     $binfmt->write ("$admindir/$name.tmp") or return 0;
  419.     unless (rename_mv "$admindir/$name.tmp", "$admindir/$name") {
  420.         warning "unable to install $admindir/$name.tmp as",
  421.             "$admindir/$name: $!";
  422.         return 0;
  423.     }
  424.     }
  425.     $formats{$name} = $binfmt;
  426.     unless (act_enable $name) {
  427.     warning "unable to enable binary format $name";
  428.     return 0;
  429.     }
  430.     return 1;
  431. }
  432.  
  433. # Remove a binary format from binfmt-support's database. Attempt to disable
  434. # the format in the kernel first.
  435. sub act_remove ($$)
  436. {
  437.     my $name = shift;
  438.     my $package = shift;
  439.     unless (exists $formats{$name}) {
  440.     # There may be a --force option in the future to allow entries like
  441.     # this to be removed; either they were created manually or
  442.     # update-binfmts was broken.
  443.     warning "$admindir/$name does not exist; nothing to do!";
  444.     return 0;
  445.     }
  446.     my $old_package = $formats{$name}{package};
  447.     unless ($package eq $old_package) {
  448.     $package     = '<local>' if $package eq ':';
  449.     $old_package = '<local>' if $old_package eq ':';
  450.     warning "current package is $package, but binary format already",
  451.         "installed by $old_package; not removing.";
  452.     # I don't think this should be fatal.
  453.     return 1;
  454.     }
  455.     unless (act_disable $name) {
  456.     warning "unable to disable binary format $name";
  457.     return 0;
  458.     }
  459.     if ($test) {
  460.     print "remove $admindir/$name\n";
  461.     } else {
  462.     unless (unlink "$admindir/$name") {
  463.         warning "unable to remove $admindir/$name: $!";
  464.         return 0;
  465.     }
  466.     delete $formats{$name};
  467.     }
  468.     return 1;
  469. }
  470.  
  471. # Import a new format file into binfmt-support's database. This is intended
  472. # for use by packaging systems.
  473. sub act_import (;$);
  474. sub act_import (;$)
  475. {
  476.     my $name = shift;
  477.     if (defined $name) {
  478.     my $id;
  479.     if ($name =~ m!.*/(.*)!) {
  480.         $id = $1;
  481.     } else {
  482.         $id = $name;
  483.         $name = "$importdir/$name";
  484.     }
  485.  
  486.     if ($id =~ /^(\.\.?|register|status)$/) {
  487.         warning "binary format name '$id' is reserved";
  488.         return 0;
  489.     }
  490.  
  491.     my %import = get_import $name;
  492.     unless (scalar keys %import) {
  493.         warning "couldn't find information about '$id' to import";
  494.         return 0;
  495.     }
  496.  
  497.     if (exists $formats{$id}) {
  498.         if ($formats{$id}{package} eq ':') {
  499.         # Installed version was installed manually, so don't import
  500.         # over it.
  501.         warning "preserving local changes to $id";
  502.         return 1;
  503.         } else {
  504.         # Installed version was installed by a package, so it should
  505.         # be OK to replace it.
  506.         }
  507.     }
  508.  
  509.     # TODO: This duplicates the verification code below slightly.
  510.     unless (defined $import{package}) {
  511.         warning "$name: required 'package' line missing";
  512.         return 0;
  513.     }
  514.  
  515.     unless (-x $import{interpreter}) {
  516.         warning "$name: no executable $import{interpreter} found, but",
  517.             "continuing anyway as you request";
  518.     }
  519.  
  520.     act_install $id, Binfmt::Format->new ($name, %import);
  521.     return 1;
  522.     } else {
  523.     local *IMPORTDIR;
  524.     unless (opendir IMPORTDIR, $importdir) {
  525.         warning "unable to open $importdir: $!";
  526.         return 0;
  527.     }
  528.     my $worked = 1;
  529.     for (readdir IMPORTDIR) {
  530.         next unless -f "$importdir/$_";
  531.         if (-f "$importdir/$_") {
  532.         $worked &= act_import $_;
  533.         }
  534.     }
  535.     closedir IMPORTDIR;
  536.     return $worked;
  537.     }
  538. }
  539.  
  540. # Display a format stored in binfmt-support's database.
  541. sub act_display (;$);
  542. sub act_display (;$)
  543. {
  544.     my $name = shift;
  545.     if (defined $name) {
  546.     print "$name (", (-e "$procdir/$name" ? 'enabled' : 'disabled'),
  547.           "):\n";
  548.     my $binfmt = $formats{$name};
  549.     my $package = $binfmt->{package} eq ':' ? '<local>'
  550.                         : $binfmt->{package};
  551.     print <<EOF;
  552.      package = $package
  553.         type = $binfmt->{type}
  554.       offset = $binfmt->{offset}
  555.        magic = $binfmt->{magic}
  556.         mask = $binfmt->{mask}
  557.  interpreter = $binfmt->{interpreter}
  558.     detector = $binfmt->{detector}
  559. EOF
  560.     } else {
  561.     for my $id (keys %formats) {
  562.         act_display $id;
  563.     }
  564.     closedir ADMINDIR;
  565.     }
  566.     return 1;
  567. }
  568.  
  569. # Now go.
  570.  
  571. check_supported_os;
  572.  
  573. my @modes = qw(install remove import display enable disable);
  574. my @types = qw(magic extension);
  575.  
  576. my ($package, $name);
  577. my ($mode, $type);
  578. my %spec;
  579.  
  580. my %unique_options = (
  581.     'package'    => \$package,
  582.     'mask'    => \$spec{mask},
  583.     'offset'    => \$spec{offset},
  584.     'detector'  => \$spec{detector},
  585. );
  586.  
  587. my %arguments = (
  588.     'admindir'    => ['path' => \$admindir],
  589.     'importdir'    => ['path' => \$importdir],
  590.     'install'    => ['name' => \$name, 'path' => \$spec{interpreter}],
  591.     'remove'    => ['name' => \$name, 'path' => \$spec{interpreter}],
  592.     'package'    => ['package-name' => \$package],
  593.     'magic'    => ['byte-sequence' => \$spec{magic}],
  594.     'extension'    => ['extension' => \$spec{extension}],
  595.     'mask'    => ['byte-sequence' => \$spec{mask}],
  596.     'offset'    => ['offset' => \$spec{offset}],
  597.     'detector'  => ['path' => \$spec{detector}],
  598. );
  599.  
  600. my %parser = (
  601.     'help'    => sub { usage; exit 0; },
  602.     'version'    => sub { version; exit 0; },
  603.     'test'    => sub { $test = 1; },
  604.     'install'    => sub {
  605.     -x $spec{interpreter}
  606.         or warning "no executable $spec{interpreter} found, but",
  607.                "continuing anyway as you request";
  608.     },
  609.     'remove'    => sub {
  610.     -x $spec{interpreter}
  611.         or warning "no executable $spec{interpreter} found, but",
  612.                "continuing anyway as you request";
  613.     },
  614.     'import'    => sub { $name = (@ARGV >= 1) ? shift @ARGV : undef; },
  615.     'display'    => sub { $name = (@ARGV >= 1) ? shift @ARGV : undef; },
  616.     'enable'    => sub { $name = (@ARGV >= 1) ? shift @ARGV : undef; },
  617.     'disable'    => sub { $name = (@ARGV >= 1) ? shift @ARGV : undef; },
  618.     'offset'    => sub {
  619.     $spec{offset} =~ /^\d+$/
  620.         or usage_quit 'offset must be a whole number';
  621.     },
  622.     'detector'  => sub {
  623.     -x $spec{detector}
  624.         or warning "no executable $spec{detector} found, but",
  625.                "continuing anyway as you request";
  626.     },
  627. );
  628.  
  629. while (defined($_ = shift))
  630. {
  631.     last if /^--$/;
  632.     if (!/^--(.+)$/) {
  633.     usage_quit "unknown argument '$_'";
  634.     }
  635.     my $option = $1;
  636.     my $is_mode = grep { $_ eq $option } @modes;
  637.     my $is_type = grep { $_ eq $option } @types;
  638.     my $has_args = exists $arguments{$option};
  639.  
  640.     unless ($is_mode or $is_type or $has_args or exists $parser{$option}) {
  641.     usage_quit "unknown argument '$_'";
  642.     }
  643.  
  644.     check_modes $mode, $option if $is_mode;
  645.     check_types $type, $option if $is_type;
  646.  
  647.     if (exists $unique_options{$option} and
  648.     defined ${$unique_options{$option}}) {
  649.     usage_quit "more than one --$option option given";
  650.     }
  651.  
  652.     if ($has_args) {
  653.     my (@descs, @varrefs);
  654.     # Split into descriptions and variable references.
  655.     my $alt = 0;
  656.     foreach my $arg (@{$arguments{$option}}) {
  657.         if (($alt = !$alt))    { push @descs, "<$arg>"; }
  658.         else        { push @varrefs, $arg; }
  659.     }
  660.     usage_quit "--$option needs @descs" unless @ARGV >= @descs;
  661.     foreach my $varref (@varrefs) { $$varref = shift @ARGV; }
  662.     }
  663.  
  664.     &{$parser{$option}} if defined $parser{$option};
  665.  
  666.     $mode = $option if $is_mode;
  667.     $type = $option if $is_type;
  668. }
  669.  
  670. $package = ':' unless defined $package;
  671.  
  672. unless (defined $mode) {
  673.     usage_quit 'you must use one of --install, --remove, --import, --display,',
  674.            '--enable, --disable';
  675. }
  676.  
  677. my $binfmt;
  678. if ($mode eq 'install') {
  679.     defined $type or usage_quit '--install requires a <spec> option';
  680.     if ($name =~ /^(\.\.?|register|status)$/) {
  681.     usage_quit "binary format name '$name' is reserved";
  682.     }
  683.     $binfmt = Binfmt::Format->new ($name, package => $package, type => $type,
  684.                    %spec);
  685. }
  686.  
  687. local *ADMINDIR;
  688. unless (opendir ADMINDIR, $admindir) {
  689.     quit "unable to open $admindir: $!";
  690. }
  691. for my $name (readdir ADMINDIR) {
  692.     if (-f "$admindir/$name") {
  693.     my $format = Binfmt::Format->load ($name, "$admindir/$name");
  694.     $formats{$name} = $format if defined $format;
  695.     }
  696. }
  697. closedir ADMINDIR;
  698.  
  699. my %actions = (
  700.     'install'    => [\&act_install, $binfmt],
  701.     'remove'    => [\&act_remove, $package],
  702.     'import'    => [\&act_import],
  703.     'display'    => [\&act_display],
  704.     'enable'    => [\&act_enable],
  705.     'disable'    => [\&act_disable],
  706. );
  707.  
  708. unless (exists $actions{$mode}) {
  709.     usage_quit "unknown mode: $mode";
  710. }
  711.  
  712. my @actargs = @{$actions{$mode}};
  713. my $actsub = shift @actargs;
  714. if ($actsub->($name, @actargs)) {
  715.     exit 0;
  716. } else {
  717.     quit 'exiting due to previous errors';
  718. }
  719.